home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0193.ZIP / STRNGLIB.INC < prev    next >
Text File  |  1985-02-23  |  8KB  |  308 lines
  1. { Suplementry String functions and procedures For Turbo Pascal  }
  2. Type
  3.   LString = String[80];
  4.  
  5. function LoCase(InChar: Char): Char;
  6. { convert a Character to lower case }
  7. Begin
  8.    If InChar IN ['A'..'Z'] then
  9.       LoCase := Chr(Ord(InChar)+32)
  10.    Else
  11.       LoCase := InChar
  12. End;
  13.  
  14. function LowerCase(InpStr: LString): LString;
  15. { convert a String to lower case Characters }
  16. Var i : Integer;
  17. Begin
  18.    For i := 1 to Length(InpStr) do
  19.        LowerCase[i] := LoCase(InpStr[i]);
  20.    LowerCase[0] := InpStr[0]
  21. End;
  22.  
  23. function UpperCase(InpStr: LString): LString;
  24. { convert a String to upper case Characters }
  25. Var i : Integer;
  26. Begin
  27.    For i := 1 to Length(InpStr) do
  28.        UpperCase[i] := UpCase(InpStr[i]);
  29.    UpperCase[0] := InpStr[0]
  30. End;
  31.  
  32. function TrimL(InpStr: LString): LString;
  33. { strip leading spaces from a String }
  34. Var i,len : Integer;
  35. Begin
  36.    len := length(InpStr);
  37.    i := 1;
  38.    While (i <= len) and (InpStr[i] = ' ') do
  39.       i := i + 1;
  40.    TrimL := Copy(InpStr,i,len-i+1)
  41. End;
  42.  
  43. function TrimR(InpStr: LString): LString;
  44. { strip trailing spaces from a String }
  45. Var i : Integer;
  46. Begin
  47.    i := length(InpStr);
  48.    While (i >= 1) and (InpStr[i] = ' ') do
  49.       i := i - 1;
  50.    TrimR := Copy(InpStr,1,i)
  51. End;
  52.  
  53. function PadL(InpStr: LString; FieldLen: Integer): LString;
  54. { Pad String on left with spaces to fill to the desired field length }
  55. Var  STemp : LString;
  56.          i : Integer;
  57. Begin
  58.    If FieldLen >= SizeOF(InpStr) then
  59.       FieldLen := SizeOf(InpStr)-1;
  60.    If length(InpStr) > FieldLen then
  61.       PadL := Copy(InpStr,1,FieldLen)
  62.    Else
  63.       Begin
  64.         STemp := InpStr;
  65.         For i := Length(STemp)+1 to FieldLen do
  66.            Insert(' ',STemp,1);
  67.         PadL := STemp
  68.       End
  69. End;
  70.  
  71. function PadR(InpStr: LString; FieldLen: Integer): LString;
  72. { Pad String on right with spaces to fill to the desired field length }
  73. Var  STemp : LString;
  74.          i : Integer;
  75. Begin
  76.    If FieldLen >= SizeOF(InpStr) then
  77.       FieldLen := SizeOf(InpStr)-1;
  78.    If length(InpStr) > FieldLen then
  79.       PadR := Copy(InpStr,1,FieldLen)
  80.    Else
  81.       Begin
  82.         STemp := InpStr;
  83.         For i := Length(STemp)+1 to FieldLen do
  84.            STemp := STemp + ' ';
  85.         PadR := STemp
  86.       End
  87. End;
  88.  
  89. function JustL(InpStr: LString; FieldLen: Integer): LString;
  90. { Left justify the String within the given field length }
  91. Begin
  92.    JustL := PadR(TrimL(InpStr),FieldLen)
  93. End;
  94.  
  95. function JustR(InpStr: LString; FieldLen: Integer): LString;
  96. { Right justify the String within the given field length }
  97. Begin
  98.    JustR := PadL(TrimR(InpStr),FieldLen)
  99. End;
  100.  
  101. function Center(InpStr: LString; FieldLen: Integer): LString;
  102. { Center a String within a specified field length;  the String
  103.   is padded on both sides with spaces }
  104. Var LeadSpaces : Integer;
  105.         STemp : LString;
  106. Begin
  107.    { strip leading and trailing spaces; determine the
  108.      Number of spaces needed to center the String }
  109.    STemp := TrimR(TrimL(InpStr));
  110.    LeadSpaces := (FieldLen - Length(STemp) + 1) div 2;
  111.    { insert leading spaces then trailing spaces }
  112.    Center := PadR(PadL(STemp,FieldLen-LeadSpaces),FieldLen)
  113. End;
  114.  
  115. procedure GString(InpStr, DelStr: LString; span: boolean;
  116.                   Var cpos, dpos: Integer; Var OutStr: LString);
  117. { Return a String containing all Characters starting at position, cpos,
  118.  of the source String up to the first first occurence of any of several
  119.  delimiters.  The position of the found delimiter is returned as well
  120.  as which delimiter.
  121. }
  122. Var done : boolean;
  123. Begin
  124.    OutStr := ''; dpos := 0;
  125.    If cpos > 0 then
  126.       Begin
  127.         done := false;
  128.         While (cpos <= Length(InpStr)) and not done do
  129.            Begin
  130.              dpos := pos(InpStr[cpos],DelStr);
  131.              If span xor (dpos = 0) then
  132.                 Begin
  133.                   OutStr := OutStr + InpStr[cpos];
  134.                   cpos := cpos + 1
  135.                 End
  136.              Else
  137.                done := true
  138.            End;
  139.       If (span xor (dpos = 0)) or (cpos > length(InpStr)) then cpos := 0
  140.     End
  141. End;
  142.  
  143. function GetStr(InpStr: LString; Delim: Char): LString;
  144. { Return a String containing all Characters starting at the
  145.   first position of the source String up to the first delimiter.
  146. }
  147. Var i : Integer;
  148. Begin
  149.    i := Pos(Delim,InpStr);
  150.    If i = 0 then
  151.       Begin
  152.         GetStr := InpStr;
  153.         InpStr := ''
  154.       End
  155.    Else
  156.       Begin
  157.         GetStr := Copy(InpStr,1,i-1);
  158.         Delete(InpStr,1,i)
  159.       End
  160. End;
  161.  
  162. function Break(InpStr: LString; DelStr: LString): LString;
  163. { Emulate SNOBOL BREAK function }
  164. Var cp, dp : Integer;
  165.     OutStr : LString;
  166. Begin
  167.    cp := 1;
  168.    GString(InpStr,DelStr,false,cp,dp,OutStr);
  169.    Break := OutStr;
  170.    If cp = 0 then
  171.       InpStr := ''
  172.    Else
  173.       Delete(InpStr,1,cp-1)
  174. End;
  175.  
  176. function Span(InpStr: LString; DelStr: LString): LString;
  177. { Emulate SNOBOL SPAN function }
  178. Var cp, dp : Integer;
  179.     OutStr : LString;
  180. Begin
  181.    cp := 1;
  182.    GString(InpStr,DelStr,true,cp,dp,OutStr);
  183.    Span := OutStr;
  184.    If cp = 0 then
  185.       InpStr := ''
  186.    Else
  187.       Delete(InpStr,1,cp-1)
  188. End;
  189.  
  190. Procedure RealStr(Valu: Real; Base, Trail: Integer;
  191.                   Var OutStr: LString);
  192. { Convert a real value to a String }
  193. Var
  194.    i, digit, MaxLen : Integer;
  195.    IntValu, FracValu : real;
  196.    Sign : boolean;
  197.  
  198. function NewDigit(num:Integer): Char;
  199. Begin
  200.    If num < 10 then
  201.       NewDigit := chr(num + ord('0'))
  202.    Else
  203.       NewDigit := chr(num + ord('A') - 10)
  204. End;
  205.  
  206. Begin
  207.    MaxLen := SizeOf(OutStr);
  208.    If Valu < 0 then
  209.       Begin
  210.         Valu := - Valu;
  211.         Sign := true
  212.       End
  213.    Else
  214.       Sign := false;
  215.    IntValu := Int(Valu);
  216.    FracValu := Frac(Valu);
  217.    If Valu < 1 then
  218.       OutStr := '0'
  219.    Else
  220.       Begin
  221.       { convert Leading digits to a String }
  222.         OutStr := '';
  223.         While (IntValu >= 1) and (Length(OutStr) < MaxLen) do
  224.            Begin
  225.              Valu := IntValu / Base;
  226.              Digit := Trunc(Round(Frac(Valu)*Base));
  227.              IntValu := Int(Valu);
  228.              Insert(NewDigit(digit),OutStr,1);
  229.            End
  230.       End;
  231.    If (Trail > 0) and ( length(OutStr) < MaxLen) then
  232.       Begin
  233.       { convert trialing digits }
  234.         OutStr := OutStr + '.';
  235.         i := 1;
  236.         While (Length(OutStr) < MaxLen) and (i <= Trail) do
  237.            Begin
  238.              Valu := FracValu * Base;
  239.              Digit := Trunc(Valu);
  240.              FracValu := Frac(Valu);
  241.              OutStr := OutStr + NewDigit(Digit);
  242.              i := i + 1
  243.            End
  244.       End;
  245.     If sign then Insert('-',OutStr,1);
  246. End;
  247.  
  248. Procedure RealVal(InpStr: LString; Base: Integer;
  249.                   Var Err: Integer; Var Valu: real);
  250. { convert a String to a real value }
  251. Var
  252.   i, digit : Integer;
  253.   GotRadixPoint,GotDigit,Negate : boolean;
  254.   InChar : Char;
  255.   InvBase : real;
  256. Begin
  257.    Valu := 0;
  258.    Err := 0;
  259.    negate := false;
  260.    i := 0;
  261.    InvBase := 1;
  262.    GotRadixPoint := false;
  263.    While (i < length(InpStr)) and (err = 0) do
  264.      Begin
  265.         i := i + 1;
  266.         GotDigit := false;
  267.         InChar := UpCase(InpStr[i]);
  268.         case InChar of
  269.           '0'..'9':
  270.              Begin
  271.                digit := ord(InpStr[i]) - ord('0');
  272.                GotDigit := true
  273.              End;
  274.           'A'..'Z':
  275.              Begin
  276.                digit := ord(InChar) - ord('A') + 10;
  277.                GotDigit := true
  278.              End;
  279.           '-' :
  280.              Begin
  281.                If negate then
  282.                  err := i
  283.                Else
  284.                  negate := true
  285.              End;
  286.           '+' : If negate then err := i;
  287.           '.' : If GotRadixPoint then
  288.                       err := i
  289.                    Else
  290.                       GotRadixPoint := true;
  291.          Else    err := i
  292.          End  {case} ;
  293.       If GotDigit then
  294.          If digit >= base then
  295.             err := i
  296.          Else
  297.             If GotRadixPoint then
  298.                Begin
  299.                  InvBase := InvBase / base;
  300.                  Valu := Valu + InvBase * digit
  301.                End
  302.             Else
  303.                Valu := Valu * base + digit
  304.       End; { While }
  305.    If negate then
  306.       valu := - valu;
  307. End;
  308.